home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclCmdIL.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-01  |  36.6 KB  |  1,413 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_CMD_IL
  3. #endif
  4.  
  5. /* 
  6.  * tclCmdIL.c --
  7.  *
  8.  *    This file contains the top-level command routines for most of
  9.  *    the Tcl built-in commands whose names begin with the letters
  10.  *    I through L.  It contains only commands in the generic core
  11.  *    (i.e. those that don't depend much upon UNIX facilities).
  12.  *
  13.  * Copyright (c) 1987-1993 The Regents of the University of California.
  14.  * All rights reserved.
  15.  *
  16.  * Permission is hereby granted, without written agreement and without
  17.  * license or royalty fees, to use, copy, modify, and distribute this
  18.  * software and its documentation for any purpose, provided that the
  19.  * above copyright notice and the following two paragraphs appear in
  20.  * all copies of this software.
  21.  * 
  22.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  23.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  24.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  25.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26.  *
  27.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  28.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  29.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  30.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  31.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  32.  */
  33.  
  34. #ifndef lint
  35. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.102 93/08/18 16:07:13 ouster Exp $ SPRITE (Berkeley)";
  36. #endif
  37.  
  38. #include "tclInt.h"
  39. #include "patchlevel.h"
  40.  
  41. /*
  42.  * The variables below are used to implement the "lsort" command.
  43.  * Unfortunately, this use of static variables prevents "lsort"
  44.  * from being thread-safe, but there's no alternative given the
  45.  * current implementation of qsort.  In a threaded environment
  46.  * these variables should be made thread-local if possible, or else
  47.  * "lsort" needs internal mutual exclusion.
  48.  */
  49.  
  50. static Tcl_Interp *sortInterp;        /* Interpreter for "lsort" command. */
  51. static enum {ASCII, INTEGER, REAL, COMMAND} sortMode;
  52.                     /* Mode for sorting: compare as strings,
  53.                      * compare as numbers, or call
  54.                      * user-defined command for
  55.                      * comparison. */
  56. static Tcl_DString sortCmd;        /* Holds command if mode is COMMAND.
  57.                      * pre-initialized to hold base of
  58.                      * command. */
  59. static int sortIncreasing;        /* 0 means sort in decreasing order,
  60.                      * 1 means increasing order. */
  61. static int sortCode;            /* Anything other than TCL_OK means a
  62.                      * problem occurred while sorting; this
  63.                      * executing a comparison command, so
  64.                      * the sort was aborted. */
  65.  
  66. /*
  67.  * Forward declarations for procedures defined in this file:
  68.  */
  69.  
  70. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  71.                 CONST VOID *second));
  72.  
  73. /*
  74.  *----------------------------------------------------------------------
  75.  *
  76.  * Tcl_IfCmd --
  77.  *
  78.  *    This procedure is invoked to process the "if" Tcl command.
  79.  *    See the user documentation for details on what it does.
  80.  *
  81.  * Results:
  82.  *    A standard Tcl result.
  83.  *
  84.  * Side effects:
  85.  *    See the user documentation.
  86.  *
  87.  *----------------------------------------------------------------------
  88.  */
  89.  
  90.     /* ARGSUSED */
  91. int
  92. Tcl_IfCmd(dummy, interp, argc, argv)
  93.     ClientData dummy;            /* Not used. */
  94.     Tcl_Interp *interp;            /* Current interpreter. */
  95.     int argc;                /* Number of arguments. */
  96.     char **argv;            /* Argument strings. */
  97. {
  98.     int i, result, value;
  99.  
  100.     i = 1;
  101.     while (1) {
  102.     /*
  103.      * At this point in the loop, argv and argc refer to an expression
  104.      * to test, either for the main expression or an expression
  105.      * following an "elseif".  The arguments after the expression must
  106.      * be "then" (optional) and a script to execute if the expression is
  107.      * true.
  108.      */
  109.  
  110.     if (i >= argc) {
  111.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  112.             argv[i-1], "\" argument", (char *) NULL);
  113.         return TCL_ERROR;
  114.     }
  115.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  116.     if (result != TCL_OK) {
  117.         return result;
  118.     }
  119.     i++;
  120.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  121.         i++;
  122.     }
  123.     if (i >= argc) {
  124.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  125.             argv[i-1], "\" argument", (char *) NULL);
  126.         return TCL_ERROR;
  127.     }
  128.     if (value) {
  129.         return Tcl_Eval(interp, argv[i]);
  130.     }
  131.  
  132.     /*
  133.      * The expression evaluated to false.  Skip the command, then
  134.      * see if there is an "else" or "elseif" clause.
  135.      */
  136.  
  137.     i++;
  138.     if (i >= argc) {
  139.         return TCL_OK;
  140.     }
  141.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  142.         i++;
  143.         continue;
  144.     }
  145.     break;
  146.     }
  147.  
  148.     /*
  149.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  150.      * for an "else" clause.  We know that there's at least one more
  151.      * argument when we get here.
  152.      */
  153.  
  154.     if (strcmp(argv[i], "else") == 0) {
  155.     i++;
  156.     if (i >= argc) {
  157.         Tcl_AppendResult(interp,
  158.             "wrong # args: no script following \"else\" argument",
  159.             (char *) NULL);
  160.         return TCL_ERROR;
  161.     }
  162.     }
  163.     return Tcl_Eval(interp, argv[i]);
  164. }
  165.  
  166. /*
  167.  *----------------------------------------------------------------------
  168.  *
  169.  * Tcl_IncrCmd --
  170.  *
  171.  *    This procedure is invoked to process the "incr" Tcl command.
  172.  *    See the user documentation for details on what it does.
  173.  *
  174.  * Results:
  175.  *    A standard Tcl result.
  176.  *
  177.  * Side effects:
  178.  *    See the user documentation.
  179.  *
  180.  *----------------------------------------------------------------------
  181.  */
  182.  
  183.     /* ARGSUSED */
  184. int
  185. Tcl_IncrCmd(dummy, interp, argc, argv)
  186.     ClientData dummy;            /* Not used. */
  187.     Tcl_Interp *interp;            /* Current interpreter. */
  188.     int argc;                /* Number of arguments. */
  189.     char **argv;            /* Argument strings. */
  190. {
  191.     int value;
  192.     char *oldString, *result;
  193.     char newString[30];
  194.  
  195.     if ((argc != 2) && (argc != 3)) {
  196.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  197.         " varName ?increment?\"", (char *) NULL);
  198.     return TCL_ERROR;
  199.     }
  200.  
  201.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  202.     if (oldString == NULL) {
  203.     return TCL_ERROR;
  204.     }
  205.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  206.     Tcl_AddErrorInfo(interp,
  207.         "\n    (reading value of variable to increment)");
  208.     return TCL_ERROR;
  209.     }
  210.     if (argc == 2) {
  211.     value += 1;
  212.     } else {
  213.     int increment;
  214.  
  215.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  216.         Tcl_AddErrorInfo(interp,
  217.             "\n    (reading increment)");
  218.         return TCL_ERROR;
  219.     }
  220.     value += increment;
  221.     }
  222.     sprintf(newString, "%d", value);
  223.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  224.     if (result == NULL) {
  225.     return TCL_ERROR;
  226.     }
  227.     interp->result = result;
  228.     return TCL_OK; 
  229. }
  230.  
  231. /*
  232.  *----------------------------------------------------------------------
  233.  *
  234.  * Tcl_InfoCmd --
  235.  *
  236.  *    This procedure is invoked to process the "info" Tcl command.
  237.  *    See the user documentation for details on what it does.
  238.  *
  239.  * Results:
  240.  *    A standard Tcl result.
  241.  *
  242.  * Side effects:
  243.  *    See the user documentation.
  244.  *
  245.  *----------------------------------------------------------------------
  246.  */
  247.  
  248.     /* ARGSUSED */
  249. int
  250. Tcl_InfoCmd(dummy, interp, argc, argv)
  251.     ClientData dummy;            /* Not used. */
  252.     Tcl_Interp *interp;            /* Current interpreter. */
  253.     int argc;                /* Number of arguments. */
  254.     char **argv;            /* Argument strings. */
  255. {
  256.     register Interp *iPtr = (Interp *) interp;
  257.     int length;
  258.     char c;
  259.     Arg *argPtr;
  260.     Proc *procPtr;
  261.     Var *varPtr;
  262.     Command *cmdPtr;
  263.     Tcl_HashEntry *hPtr;
  264.     Tcl_HashSearch search;
  265.     
  266.     extern char *tcl_getenv();
  267.  
  268.     if (argc < 2) {
  269.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  270.         " option ?arg arg ...?\"", (char *) NULL);
  271.     return TCL_ERROR;
  272.     }
  273.     c = argv[1][0];
  274.     length = strlen(argv[1]);
  275.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  276.     if (argc != 3) {
  277.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  278.             argv[0], " args procname\"", (char *) NULL);
  279.         return TCL_ERROR;
  280.     }
  281.     procPtr = TclFindProc(iPtr, argv[2]);
  282.     if (procPtr == NULL) {
  283.         infoNoSuchProc:
  284.         Tcl_AppendResult(interp, "\"", argv[2],
  285.             "\" isn't a procedure", (char *) NULL);
  286.         return TCL_ERROR;
  287.     }
  288.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  289.         argPtr = argPtr->nextPtr) {
  290.         Tcl_AppendElement(interp, argPtr->name);
  291.     }
  292.     return TCL_OK;
  293.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  294.     if (argc != 3) {
  295.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  296.             " body procname\"", (char *) NULL);
  297.         return TCL_ERROR;
  298.     }
  299.     procPtr = TclFindProc(iPtr, argv[2]);
  300.     if (procPtr == NULL) {
  301.         goto infoNoSuchProc;
  302.     }
  303.     iPtr->result = procPtr->command;
  304.     return TCL_OK;
  305.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  306.         && (length >= 2)) {
  307.     if (argc != 2) {
  308.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  309.             " cmdcount\"", (char *) NULL);
  310.         return TCL_ERROR;
  311.     }
  312.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  313.     return TCL_OK;
  314.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  315.         && (length >= 4)) {
  316.     if (argc > 3) {
  317.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  318.             " commands [pattern]\"", (char *) NULL);
  319.         return TCL_ERROR;
  320.     }
  321.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  322.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  323.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  324.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  325.         continue;
  326.         }
  327.         Tcl_AppendElement(interp, name);
  328.     }
  329.     return TCL_OK;
  330.     } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
  331.         && (length >= 4)) {
  332.     if (argc != 3) {
  333.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  334.             " complete command\"", (char *) NULL);
  335.         return TCL_ERROR;
  336.     }
  337.     if (Tcl_CommandComplete(argv[2])) {
  338.         interp->result = "1";
  339.     } else {
  340.         interp->result = "0";
  341.     }
  342.     return TCL_OK;
  343.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  344.     if (argc != 5) {
  345.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  346.             argv[0], " default procname arg varname\"",
  347.             (char *) NULL);
  348.         return TCL_ERROR;
  349.     }
  350.     procPtr = TclFindProc(iPtr, argv[2]);
  351.     if (procPtr == NULL) {
  352.         goto infoNoSuchProc;
  353.     }
  354.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  355.         if (argPtr == NULL) {
  356.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  357.             "\" doesn't have an argument \"", argv[3],
  358.             "\"", (char *) NULL);
  359.         return TCL_ERROR;
  360.         }
  361.         if (strcmp(argv[3], argPtr->name) == 0) {
  362.         if (argPtr->defValue != NULL) {
  363.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  364.                 argPtr->defValue, 0) == NULL) {
  365.             defStoreError:
  366.             Tcl_AppendResult(interp,
  367.                 "couldn't store default value in variable \"",
  368.                 argv[4], "\"", (char *) NULL);
  369.             return TCL_ERROR;
  370.             }
  371.             iPtr->result = "1";
  372.         } else {
  373.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  374.                 == NULL) {
  375.             goto defStoreError;
  376.             }
  377.             iPtr->result = "0";
  378.         }
  379.         return TCL_OK;
  380.         }
  381.     }
  382.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  383.     char *p;
  384.     if (argc != 3) {
  385.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  386.             " exists varName\"", (char *) NULL);
  387.         return TCL_ERROR;
  388.     }
  389.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  390.  
  391.     /*
  392.      * The code below handles the special case where the name is for
  393.      * an array:  Tcl_GetVar will reject this since you can't read
  394.      * an array variable without an index.
  395.      */
  396.  
  397.     if (p == NULL) {
  398.         Tcl_HashEntry *hPtr;
  399.         Var *varPtr;
  400.  
  401.         if (strchr(argv[2], '(') != NULL) {
  402.         noVar:
  403.         iPtr->result = "0";
  404.         return TCL_OK;
  405.         }
  406.         if (iPtr->varFramePtr == NULL) {
  407.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  408.         } else {
  409.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  410.         }
  411.         if (hPtr == NULL) {
  412.         goto noVar;
  413.         }
  414.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  415.         if (varPtr->flags & VAR_UPVAR) {
  416.         varPtr = varPtr->value.upvarPtr;
  417.         }
  418.         if (!(varPtr->flags & VAR_ARRAY)) {
  419.         goto noVar;
  420.         }
  421.     }
  422.     iPtr->result = "1";
  423.     return TCL_OK;
  424.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  425.     char *name;
  426.  
  427.     if (argc > 3) {
  428.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  429.             " globals [pattern]\"", (char *) NULL);
  430.         return TCL_ERROR;
  431.     }
  432.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  433.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  434.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  435.         if (varPtr->flags & VAR_UNDEFINED) {
  436.         continue;
  437.         }
  438.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  439.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  440.         continue;
  441.         }
  442.         Tcl_AppendElement(interp, name);
  443.     }
  444.     return TCL_OK;
  445.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  446.         && (length >= 2)) {
  447.     if (argc == 2) {
  448.         if (iPtr->varFramePtr == NULL) {
  449.         iPtr->result = "0";
  450.         } else {
  451.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  452.         }
  453.         return TCL_OK;
  454.     } else if (argc == 3) {
  455.         int level;
  456.         CallFrame *framePtr;
  457.  
  458.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  459.         return TCL_ERROR;
  460.         }
  461.         if (level <= 0) {
  462.         if (iPtr->varFramePtr == NULL) {
  463.             levelError:
  464.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  465.                 "\"", (char *) NULL);
  466.             return TCL_ERROR;
  467.         }
  468.         level += iPtr->varFramePtr->level;
  469.         }
  470.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  471.             framePtr = framePtr->callerVarPtr) {
  472.         if (framePtr->level == level) {
  473.             break;
  474.         }
  475.         }
  476.         if (framePtr == NULL) {
  477.         goto levelError;
  478.         }
  479.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  480.         iPtr->freeProc = (Tcl_FreeProc *) free;
  481.         return TCL_OK;
  482.     }
  483.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  484.         " level [number]\"", (char *) NULL);
  485.     return TCL_ERROR;
  486.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  487.         && (length >= 2)) {
  488.     if (argc != 2) {
  489.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  490.             " library\"", (char *) NULL);
  491.         return TCL_ERROR;
  492.     }
  493.     interp->result = tcl_getenv("TCL_LIBRARY");
  494.     if (interp->result == NULL) {
  495. #ifdef TCL_LIBRARY
  496.         interp->result = TCL_LIBRARY;
  497. #else
  498.         interp->result = "there is no Tcl library at this installation";
  499.         return TCL_ERROR;
  500. #endif
  501.     }
  502.     return TCL_OK;
  503.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  504.         && (length >= 2)) {
  505.     char *name;
  506.  
  507.     if (argc > 3) {
  508.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  509.             " locals [pattern]\"", (char *) NULL);
  510.         return TCL_ERROR;
  511.     }
  512.     if (iPtr->varFramePtr == NULL) {
  513.         return TCL_OK;
  514.     }
  515.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  516.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  517.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  518.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  519.         continue;
  520.         }
  521.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  522.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  523.         continue;
  524.         }
  525.         Tcl_AppendElement(interp, name);
  526.     }
  527.     return TCL_OK;
  528.     } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
  529.         && (length >= 2)) {
  530.     if (argc != 2) {
  531.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  532.             " patchlevel\"", (char *) NULL);
  533.         return TCL_ERROR;
  534.     }
  535.     sprintf(interp->result, "%d", TCL_PATCH_LEVEL);
  536.     return TCL_OK;
  537.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0)
  538.         && (length >= 2)) {
  539.     if (argc > 3) {
  540.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  541.             " procs [pattern]\"", (char *) NULL);
  542.         return TCL_ERROR;
  543.     }
  544.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  545.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  546.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  547.  
  548.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  549.         if (!TclIsProc(cmdPtr)) {
  550.         continue;
  551.         }
  552.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  553.         continue;
  554.         }
  555.         Tcl_AppendElement(interp, name);
  556.     }
  557.     return TCL_OK;
  558.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  559.     if (argc != 2) {
  560.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  561.             argv[0], " script\"", (char *) NULL);
  562.         return TCL_ERROR;
  563.     }
  564.     if (iPtr->scriptFile != NULL) {
  565.         /*
  566.          * Can't depend on iPtr->scriptFile to be non-volatile:
  567.          * if this command is returned as the result of the script,
  568.          * then iPtr->scriptFile will go away.
  569.          */
  570.  
  571.         Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE);
  572.     }
  573.     return TCL_OK;
  574.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  575.     if (argc != 2) {
  576.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  577.             argv[0], " tclversion\"", (char *) NULL);
  578.         return TCL_ERROR;
  579.     }
  580.  
  581.     /*
  582.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  583.      * switch in the Makefile.
  584.      */
  585.  
  586.     strcpy(iPtr->result, TCL_VERSION);
  587.     return TCL_OK;
  588.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  589.     Tcl_HashTable *tablePtr;
  590.     char *name;
  591.  
  592.     if (argc > 3) {
  593.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  594.             argv[0], " vars [pattern]\"", (char *) NULL);
  595.         return TCL_ERROR;
  596.     }
  597.     if (iPtr->varFramePtr == NULL) {
  598.         tablePtr = &iPtr->globalTable;
  599.     } else {
  600.         tablePtr = &iPtr->varFramePtr->varTable;
  601.     }
  602.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  603.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  604.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  605.         if (varPtr->flags & VAR_UNDEFINED) {
  606.         continue;
  607.         }
  608.         name = Tcl_GetHashKey(tablePtr, hPtr);
  609.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  610.         continue;
  611.         }
  612.         Tcl_AppendElement(interp, name);
  613.     }
  614.     return TCL_OK;
  615.     } else {
  616.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  617.         "\": should be args, body, cmdcount, commands, ",
  618.         "complete, default, ",
  619.         "exists, globals, level, library, locals, ",
  620.         "patchlevel, procs, script, tclversion, or vars",
  621.         (char *) NULL);
  622.     return TCL_ERROR;
  623.     }
  624. }
  625.  
  626. /*
  627.  *----------------------------------------------------------------------
  628.  *
  629.  * Tcl_JoinCmd --
  630.  *
  631.  *    This procedure is invoked to process the "join" Tcl command.
  632.  *    See the user documentation for details on what it does.
  633.  *
  634.  * Results:
  635.  *    A standard Tcl result.
  636.  *
  637.  * Side effects:
  638.  *    See the user documentation.
  639.  *
  640.  *----------------------------------------------------------------------
  641.  */
  642.  
  643.     /* ARGSUSED */
  644. int
  645. Tcl_JoinCmd(dummy, interp, argc, argv)
  646.     ClientData dummy;            /* Not used. */
  647.     Tcl_Interp *interp;            /* Current interpreter. */
  648.     int argc;                /* Number of arguments. */
  649.     char **argv;            /* Argument strings. */
  650. {
  651.     char *joinString;
  652.     char **listArgv;
  653.     int listArgc, i;
  654.  
  655.     if (argc == 2) {
  656.     joinString = " ";
  657.     } else if (argc == 3) {
  658.     joinString = argv[2];
  659.     } else {
  660.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  661.         " list ?joinString?\"", (char *) NULL);
  662.     return TCL_ERROR;
  663.     }
  664.  
  665.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  666.     return TCL_ERROR;
  667.     }
  668.     for (i = 0; i < listArgc; i++) {
  669.     if (i == 0) {
  670.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  671.     } else  {
  672.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  673.     }
  674.     }
  675.     ckfree((char *) listArgv);
  676.     return TCL_OK;
  677. }
  678.  
  679. /*
  680.  *----------------------------------------------------------------------
  681.  *
  682.  * Tcl_LindexCmd --
  683.  *
  684.  *    This procedure is invoked to process the "lindex" Tcl command.
  685.  *    See the user documentation for details on what it does.
  686.  *
  687.  * Results:
  688.  *    A standard Tcl result.
  689.  *
  690.  * Side effects:
  691.  *    See the user documentation.
  692.  *
  693.  *----------------------------------------------------------------------
  694.  */
  695.  
  696.     /* ARGSUSED */
  697. int
  698. Tcl_LindexCmd(dummy, interp, argc, argv)
  699.     ClientData dummy;            /* Not used. */
  700.     Tcl_Interp *interp;            /* Current interpreter. */
  701.     int argc;                /* Number of arguments. */
  702.     char **argv;            /* Argument strings. */
  703. {
  704.     char *p, *element;
  705.     int index, size, parenthesized, result;
  706.  
  707.     if (argc != 3) {
  708.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  709.         " list index\"", (char *) NULL);
  710.     return TCL_ERROR;
  711.     }
  712.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  713.     return TCL_ERROR;
  714.     }
  715.     if (index < 0) {
  716.     return TCL_OK;
  717.     }
  718.     for (p = argv[1] ; index >= 0; index--) {
  719.     result = TclFindElement(interp, p, &element, &p, &size,
  720.         &parenthesized);
  721.     if (result != TCL_OK) {
  722.         return result;
  723.     }
  724.     }
  725.     if (size == 0) {
  726.     return TCL_OK;
  727.     }
  728.     if (size >= TCL_RESULT_SIZE) {
  729.     interp->result = (char *) ckalloc((unsigned) size+1);
  730.     interp->freeProc = (Tcl_FreeProc *) free;
  731.     }
  732.     if (parenthesized) {
  733.     memcpy((VOID *) interp->result, (VOID *) element, size);
  734.     interp->result[size] = 0;
  735.     } else {
  736.     TclCopyAndCollapse(size, element, interp->result);
  737.     }
  738.     return TCL_OK;
  739. }
  740.  
  741. /*
  742.  *----------------------------------------------------------------------
  743.  *
  744.  * Tcl_LinsertCmd --
  745.  *
  746.  *    This procedure is invoked to process the "linsert" Tcl command.
  747.  *    See the user documentation for details on what it does.
  748.  *
  749.  * Results:
  750.  *    A standard Tcl result.
  751.  *
  752.  * Side effects:
  753.  *    See the user documentation.
  754.  *
  755.  *----------------------------------------------------------------------
  756.  */
  757.  
  758.     /* ARGSUSED */
  759. int
  760. Tcl_LinsertCmd(dummy, interp, argc, argv)
  761.     ClientData dummy;            /* Not used. */
  762.     Tcl_Interp *interp;            /* Current interpreter. */
  763.     int argc;                /* Number of arguments. */
  764.     char **argv;            /* Argument strings. */
  765. {
  766.     char *p, *element, savedChar;
  767.     int i, index, count, result, size;
  768.  
  769.     if (argc < 4) {
  770.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  771.         " list index element ?element ...?\"", (char *) NULL);
  772.     return TCL_ERROR;
  773.     }
  774.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  775.     return TCL_ERROR;
  776.     }
  777.  
  778.     /*
  779.      * Skip over the first "index" elements of the list, then add
  780.      * all of those elements to the result.
  781.      */
  782.  
  783.     size = 0;
  784.     element = argv[1];
  785.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  786.     result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
  787.     if (result != TCL_OK) {
  788.         return result;
  789.     }
  790.     }
  791.     if (*p == 0) {
  792.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  793.     } else {
  794.     char *end;
  795.  
  796.     end = element+size;
  797.     if (element != argv[1]) {
  798.         while ((*end != 0) && !isspace(UCHAR(*end))) {
  799.         end++;
  800.         }
  801.     }
  802.     savedChar = *end;
  803.     *end = 0;
  804.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  805.     *end = savedChar;
  806.     }
  807.  
  808.     /*
  809.      * Add the new list elements.
  810.      */
  811.  
  812.     for (i = 3; i < argc; i++) {
  813.     Tcl_AppendElement(interp, argv[i]);
  814.     }
  815.  
  816.     /*
  817.      * Append the remainder of the original list.
  818.      */
  819.  
  820.     if (*p != 0) {
  821.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  822.     }
  823.     return TCL_OK;
  824. }
  825.  
  826. /*
  827.  *----------------------------------------------------------------------
  828.  *
  829.  * Tcl_ListCmd --
  830.  *
  831.  *    This procedure is invoked to process the "list" Tcl command.
  832.  *    See the user documentation for details on what it does.
  833.  *
  834.  * Results:
  835.  *    A standard Tcl result.
  836.  *
  837.  * Side effects:
  838.  *    See the user documentation.
  839.  *
  840.  *----------------------------------------------------------------------
  841.  */
  842.  
  843.     /* ARGSUSED */
  844. int
  845. Tcl_ListCmd(dummy, interp, argc, argv)
  846.     ClientData dummy;            /* Not used. */
  847.     Tcl_Interp *interp;            /* Current interpreter. */
  848.     int argc;                /* Number of arguments. */
  849.     char **argv;            /* Argument strings. */
  850. {
  851.     if (argc < 2) {
  852.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  853.         " arg ?arg ...?\"", (char *) NULL);
  854.     return TCL_ERROR;
  855.     }
  856.     interp->result = Tcl_Merge(argc-1, argv+1);
  857.     interp->freeProc = (Tcl_FreeProc *) free;
  858.     return TCL_OK;
  859. }
  860.  
  861. /*
  862.  *----------------------------------------------------------------------
  863.  *
  864.  * Tcl_LlengthCmd --
  865.  *
  866.  *    This procedure is invoked to process the "llength" Tcl command.
  867.  *    See the user documentation for details on what it does.
  868.  *
  869.  * Results:
  870.  *    A standard Tcl result.
  871.  *
  872.  * Side effects:
  873.  *    See the user documentation.
  874.  *
  875.  *----------------------------------------------------------------------
  876.  */
  877.  
  878.     /* ARGSUSED */
  879. int
  880. Tcl_LlengthCmd(dummy, interp, argc, argv)
  881.     ClientData dummy;            /* Not used. */
  882.     Tcl_Interp *interp;            /* Current interpreter. */
  883.     int argc;                /* Number of arguments. */
  884.     char **argv;            /* Argument strings. */
  885. {
  886.     int count, result;
  887.     char *element, *p;
  888.  
  889.     if (argc != 2) {
  890.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  891.         " list\"", (char *) NULL);
  892.     return TCL_ERROR;
  893.     }
  894.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  895.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  896.         (int *) NULL);
  897.     if (result != TCL_OK) {
  898.         return result;
  899.     }
  900.     if (*element == 0) {
  901.         break;
  902.     }
  903.     }
  904.     sprintf(interp->result, "%d", count);
  905.     return TCL_OK;
  906. }
  907.  
  908. /*
  909.  *----------------------------------------------------------------------
  910.  *
  911.  * Tcl_LrangeCmd --
  912.  *
  913.  *    This procedure is invoked to process the "lrange" Tcl command.
  914.  *    See the user documentation for details on what it does.
  915.  *
  916.  * Results:
  917.  *    A standard Tcl result.
  918.  *
  919.  * Side effects:
  920.  *    See the user documentation.
  921.  *
  922.  *----------------------------------------------------------------------
  923.  */
  924.  
  925.     /* ARGSUSED */
  926. int
  927. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  928.     ClientData notUsed;            /* Not used. */
  929.     Tcl_Interp *interp;            /* Current interpreter. */
  930.     int argc;                /* Number of arguments. */
  931.     char **argv;            /* Argument strings. */
  932. {
  933.     int first, last, result;
  934.     char *begin, *end, c, *dummy;
  935.     int count;
  936.  
  937.     if (argc != 4) {
  938.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  939.         " list first last\"", (char *) NULL);
  940.     return TCL_ERROR;
  941.     }
  942.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  943.     return TCL_ERROR;
  944.     }
  945.     if (first < 0) {
  946.     first = 0;
  947.     }
  948.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  949.     last = 1000000;
  950.     } else {
  951.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  952.         Tcl_ResetResult(interp);
  953.         Tcl_AppendResult(interp,
  954.             "expected integer or \"end\" but got \"",
  955.             argv[3], "\"", (char *) NULL);
  956.         return TCL_ERROR;
  957.     }
  958.     }
  959.     if (first > last) {
  960.     return TCL_OK;
  961.     }
  962.  
  963.     /*
  964.      * Extract a range of fields.
  965.      */
  966.  
  967.     for (count = 0, begin = argv[1]; count < first; count++) {
  968.     result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  969.         (int *) NULL);
  970.     if (result != TCL_OK) {
  971.         return result;
  972.     }
  973.     if (*begin == 0) {
  974.         break;
  975.     }
  976.     }
  977.     for (count = first, end = begin; (count <= last) && (*end != 0);
  978.         count++) {
  979.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  980.         (int *) NULL);
  981.     if (result != TCL_OK) {
  982.         return result;
  983.     }
  984.     }
  985.  
  986.     /*
  987.      * Chop off trailing spaces.
  988.      */
  989.  
  990.     while (isspace(UCHAR(end[-1]))) {
  991.     end--;
  992.     }
  993.     c = *end;
  994.     *end = 0;
  995.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  996.     *end = c;
  997.     return TCL_OK;
  998. }
  999.  
  1000. /*
  1001.  *----------------------------------------------------------------------
  1002.  *
  1003.  * Tcl_LreplaceCmd --
  1004.  *
  1005.  *    This procedure is invoked to process the "lreplace" Tcl command.
  1006.  *    See the user documentation for details on what it does.
  1007.  *
  1008.  * Results:
  1009.  *    A standard Tcl result.
  1010.  *
  1011.  * Side effects:
  1012.  *    See the user documentation.
  1013.  *
  1014.  *----------------------------------------------------------------------
  1015.  */
  1016.  
  1017.     /* ARGSUSED */
  1018. int
  1019. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  1020.     ClientData notUsed;            /* Not used. */
  1021.     Tcl_Interp *interp;            /* Current interpreter. */
  1022.     int argc;                /* Number of arguments. */
  1023.     char **argv;            /* Argument strings. */
  1024. {
  1025.     char *p1, *p2, *element, savedChar, *dummy;
  1026.     int i, first, last, count, result, size;
  1027.  
  1028.     if (argc < 4) {
  1029.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1030.         " list first last ?element element ...?\"", (char *) NULL);
  1031.     return TCL_ERROR;
  1032.     }
  1033.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  1034.     return TCL_ERROR;
  1035.     }
  1036.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  1037.     return TCL_ERROR;
  1038.     }
  1039.     if (first < 0) {
  1040.     first = 0;
  1041.     }
  1042.     if (last < 0) {
  1043.     last = 0;
  1044.     }
  1045.     if (first > last) {
  1046.     Tcl_AppendResult(interp, "first index must not be greater than second",
  1047.         (char *) NULL);
  1048.     return TCL_ERROR;
  1049.     }
  1050.  
  1051.     /*
  1052.      * Skip over the elements of the list before "first".
  1053.      */
  1054.  
  1055.     size = 0;
  1056.     element = argv[1];
  1057.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  1058.     result = TclFindElement(interp, p1, &element, &p1, &size,
  1059.         (int *) NULL);
  1060.     if (result != TCL_OK) {
  1061.         return result;
  1062.     }
  1063.     }
  1064.     if (*p1 == 0) {
  1065.     Tcl_AppendResult(interp, "list doesn't contain element ",
  1066.         argv[2], (char *) NULL);
  1067.     return TCL_ERROR;
  1068.     }
  1069.  
  1070.     /*
  1071.      * Skip over the elements of the list up through "last".
  1072.      */
  1073.  
  1074.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  1075.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  1076.         (int *) NULL);
  1077.     if (result != TCL_OK) {
  1078.         return result;
  1079.     }
  1080.     }
  1081.  
  1082.     /*
  1083.      * Add the elements before "first" to the result.  Be sure to
  1084.      * include quote or brace characters that might terminate the
  1085.      * last of these elements.
  1086.      */
  1087.  
  1088.     p1 = element+size;
  1089.     if (element != argv[1]) {
  1090.     while ((*p1 != 0) && !isspace(UCHAR(*p1))) {
  1091.         p1++;
  1092.     }
  1093.     }
  1094.     savedChar = *p1;
  1095.     *p1 = 0;
  1096.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1097.     *p1 = savedChar;
  1098.  
  1099.     /*
  1100.      * Add the new list elements.
  1101.      */
  1102.  
  1103.     for (i = 4; i < argc; i++) {
  1104.     Tcl_AppendElement(interp, argv[i]);
  1105.     }
  1106.  
  1107.     /*
  1108.      * Append the remainder of the original list.
  1109.      */
  1110.  
  1111.     if (*p2 != 0) {
  1112.     if (*interp->result == 0) {
  1113.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1114.     } else {
  1115.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1116.     }
  1117.     }
  1118.     return TCL_OK;
  1119. }
  1120.  
  1121. /*
  1122.  *----------------------------------------------------------------------
  1123.  *
  1124.  * Tcl_LsearchCmd --
  1125.  *
  1126.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1127.  *    See the user documentation for details on what it does.
  1128.  *
  1129.  * Results:
  1130.  *    A standard Tcl result.
  1131.  *
  1132.  * Side effects:
  1133.  *    See the user documentation.
  1134.  *
  1135.  *----------------------------------------------------------------------
  1136.  */
  1137.  
  1138.     /* ARGSUSED */
  1139. int
  1140. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1141.     ClientData notUsed;            /* Not used. */
  1142.     Tcl_Interp *interp;            /* Current interpreter. */
  1143.     int argc;                /* Number of arguments. */
  1144.     char **argv;            /* Argument strings. */
  1145. {
  1146. #define EXACT    0
  1147. #define GLOB    1
  1148. #define REGEXP    2
  1149.     int listArgc;
  1150.     char **listArgv;
  1151.     int i, match, mode, index;
  1152.  
  1153.     mode = GLOB;
  1154.     if (argc == 4) {
  1155.     if (strcmp(argv[1], "-exact") == 0) {
  1156.         mode = EXACT;
  1157.     } else if (strcmp(argv[1], "-glob") == 0) {
  1158.         mode = GLOB;
  1159.     } else if (strcmp(argv[1], "-regexp") == 0) {
  1160.         mode = REGEXP;
  1161.     } else {
  1162.         Tcl_AppendResult(interp, "bad search mode \"", argv[1],
  1163.             "\": must be -exact, -glob, or -regexp", (char *) NULL);
  1164.         return TCL_ERROR;
  1165.     }
  1166.     } else if (argc != 3) {
  1167.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1168.         " ?mode? list pattern\"", (char *) NULL);
  1169.     return TCL_ERROR;
  1170.     }
  1171.     if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) {
  1172.     return TCL_ERROR;
  1173.     }
  1174.     index = -1;
  1175.     for (i = 0; i < listArgc; i++) {
  1176.     match = 0;
  1177.     switch (mode) {
  1178.         case EXACT:
  1179.         match = (strcmp(listArgv[i], argv[argc-1]) == 0);
  1180.         break;
  1181.         case GLOB:
  1182.         match = Tcl_StringMatch(listArgv[i], argv[argc-1]);
  1183.         break;
  1184.         case REGEXP:
  1185.         match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]);
  1186.         if (match < 0) {
  1187.             ckfree((char *) listArgv);
  1188.             return TCL_ERROR;
  1189.         }
  1190.         break;
  1191.     }
  1192.     if (match) {
  1193.         index = i;
  1194.         break;
  1195.     }
  1196.     }
  1197.     sprintf(interp->result, "%d", index);
  1198.     ckfree((char *) listArgv);
  1199.     return TCL_OK;
  1200. }
  1201.  
  1202. /*
  1203.  *----------------------------------------------------------------------
  1204.  *
  1205.  * Tcl_LsortCmd --
  1206.  *
  1207.  *    This procedure is invoked to process the "lsort" Tcl command.
  1208.  *    See the user documentation for details on what it does.
  1209.  *
  1210.  * Results:
  1211.  *    A standard Tcl result.
  1212.  *
  1213.  * Side effects:
  1214.  *    See the user documentation.
  1215.  *
  1216.  *----------------------------------------------------------------------
  1217.  */
  1218.  
  1219.     /* ARGSUSED */
  1220. int
  1221. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1222.     ClientData notUsed;            /* Not used. */
  1223.     Tcl_Interp *interp;            /* Current interpreter. */
  1224.     int argc;                /* Number of arguments. */
  1225.     char **argv;            /* Argument strings. */
  1226. {
  1227.     int listArgc, i, c, length;
  1228.     char **listArgv;
  1229.     char *command = NULL;        /* Initialization needed only to
  1230.                      * prevent compiler warning. */
  1231.  
  1232.     if (argc < 2) {
  1233.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1234.         " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?",
  1235.         " ?-command string? list\"", (char *) NULL);
  1236.     return TCL_ERROR;
  1237.     }
  1238.  
  1239.     /*
  1240.      * Parse arguments to set up the mode for the sort.
  1241.      */
  1242.  
  1243.     sortInterp = interp;
  1244.     sortMode = ASCII;
  1245.     sortIncreasing = 1;
  1246.     sortCode = TCL_OK;
  1247.     for (i = 1; i < argc-1; i++) {
  1248.     length = strlen(argv[i]);
  1249.     if (length < 2) {
  1250.         badSwitch:
  1251.         Tcl_AppendResult(interp, "bad switch \"", argv[i],
  1252.             "\": must be -ascii, -integer, -real, -increasing",
  1253.             " -decreasing, or -command", (char *) NULL);
  1254.         return TCL_ERROR;
  1255.     }
  1256.     c = argv[i][1];
  1257.     if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) {
  1258.         sortMode = ASCII;
  1259.     } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) {
  1260.         if (i == argc-2) {
  1261.         Tcl_AppendResult(interp, "\"-command\" must be",
  1262.             " followed by comparison command", (char *) NULL);
  1263.         return TCL_ERROR;
  1264.         }
  1265.         sortMode = COMMAND;
  1266.         command = argv[i+1];
  1267.         i++;
  1268.     } else if ((c == 'd')
  1269.         && (strncmp(argv[i], "-decreasing", length) == 0)) {
  1270.         sortIncreasing = 0;
  1271.     } else if ((c == 'i') && (length >= 4)
  1272.         && (strncmp(argv[i], "-increasing", length) == 0)) {
  1273.         sortIncreasing = 1;
  1274.     } else if ((c == 'i') && (length >= 4)
  1275.         && (strncmp(argv[i], "-integer", length) == 0)) {
  1276.         sortMode = INTEGER;
  1277.     } else if ((c == 'r')
  1278.         && (strncmp(argv[i], "-real", length) == 0)) {
  1279.         sortMode = REAL;
  1280.     } else {
  1281.         goto badSwitch;
  1282.     }
  1283.     }
  1284.     if (sortMode == COMMAND) {
  1285.     Tcl_DStringInit(&sortCmd);
  1286.     Tcl_DStringAppend(&sortCmd, command, -1);
  1287.     }
  1288.  
  1289.     if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) {
  1290.     return TCL_ERROR;
  1291.     }
  1292.     qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
  1293.     if (sortCode == TCL_OK) {
  1294.     Tcl_ResetResult(interp);
  1295.     interp->result = Tcl_Merge(listArgc, listArgv);
  1296.     interp->freeProc = (Tcl_FreeProc *) free;
  1297.     }
  1298.     if (sortMode == COMMAND) {
  1299.     Tcl_DStringFree(&sortCmd);
  1300.     }
  1301.     ckfree((char *) listArgv);
  1302.     return sortCode;
  1303. }
  1304.  
  1305. /*
  1306.  *----------------------------------------------------------------------
  1307.  *
  1308.  * SortCompareProc --
  1309.  *
  1310.  *    This procedure is invoked by qsort to determine the proper
  1311.  *    ordering between two elements.
  1312.  *
  1313.  * Results:
  1314.  *    < 0 means first is "smaller" than "second", > 0 means "first"
  1315.  *    is larger than "second", and 0 means they should be treated
  1316.  *    as equal.
  1317.  *
  1318.  * Side effects:
  1319.  *    None, unless a user-defined comparison command does something
  1320.  *    weird.
  1321.  *
  1322.  *----------------------------------------------------------------------
  1323.  */
  1324.  
  1325. static int
  1326. SortCompareProc(first, second)
  1327.     CONST VOID *first, *second;        /* Elements to be compared. */
  1328. {
  1329.     int order;
  1330.     char *firstString = *((char **) first);
  1331.     char *secondString = *((char **) second);
  1332.  
  1333.     order = 0;
  1334.     if (sortCode != TCL_OK) {
  1335.     /*
  1336.      * Once an error has occurred, skip any future comparisons
  1337.      * so as to preserve the error message in sortInterp->result.
  1338.      */
  1339.  
  1340.     return order;
  1341.     }
  1342.     if (sortMode == ASCII) {
  1343.     order = strcmp(firstString, secondString);
  1344.     } else if (sortMode == INTEGER) {
  1345.     int a, b;
  1346.  
  1347.     if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK)
  1348.         || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) {
  1349.         Tcl_AddErrorInfo(sortInterp,
  1350.             "\n    (converting list element from string to integer)");
  1351.         sortCode = TCL_ERROR;
  1352.         return order;
  1353.     }
  1354.     if (a > b) {
  1355.         order = 1;
  1356.     } else if (b > a) {
  1357.         order = -1;
  1358.     }
  1359.     } else if (sortMode == REAL) {
  1360.     double a, b;
  1361.  
  1362.     if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK)
  1363.         || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) {
  1364.         Tcl_AddErrorInfo(sortInterp,
  1365.             "\n    (converting list element from string to real)");
  1366.         sortCode = TCL_ERROR;
  1367.         return order;
  1368.     }
  1369.     if (a > b) {
  1370.         order = 1;
  1371.     } else if (b > a) {
  1372.         order = -1;
  1373.     }
  1374.     } else {
  1375.     int oldLength;
  1376.     char *end;
  1377.  
  1378.     /*
  1379.      * Generate and evaluate a command to determine which string comes
  1380.      * first.
  1381.      */
  1382.  
  1383.     oldLength = Tcl_DStringLength(&sortCmd);
  1384.     Tcl_DStringAppendElement(&sortCmd, firstString);
  1385.     Tcl_DStringAppendElement(&sortCmd, secondString);
  1386.     sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd));
  1387.     Tcl_DStringTrunc(&sortCmd, oldLength);
  1388.     if (sortCode != TCL_OK) {
  1389.         Tcl_AddErrorInfo(sortInterp,
  1390.             "\n    (user-defined comparison command)");
  1391.         return order;
  1392.     }
  1393.  
  1394.     /*
  1395.      * Parse the result of the command.
  1396.      */
  1397.  
  1398.     order = strtol(sortInterp->result, &end, 0);
  1399.     if ((end == sortInterp->result) || (*end != 0)) {
  1400.         Tcl_ResetResult(sortInterp);
  1401.         Tcl_AppendResult(sortInterp,
  1402.             "comparison command returned non-numeric result",
  1403.             (char *) NULL);
  1404.         sortCode = TCL_ERROR;
  1405.         return order;
  1406.     }
  1407.     }
  1408.     if (!sortIncreasing) {
  1409.     order = -order;
  1410.     }
  1411.     return order;
  1412. }
  1413.